COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(declare (fasload struct fas dsk (mac lsp)))
C00011 ENDMK
C⊗;
(declare (fasload struct fas dsk (mac lsp)))

(defstruct node-record
 (count 0)
 (name nil)
 (already-visited nil)
 (direct-superclasses ())
 (direct-siblings ()))

(defmacro unless (x . y) `(cond ((not ,x) ,@y)))

(defmacro when (x . y) `(cond (,x ,@y)))

(defmacro incf (loc) `(setf ,loc (+ ,loc 1)))

(defmacro decf (loc) `(setf ,loc (+ ,loc -1)))

(defmacro node-record (node) `(cadr ,node))

(defmacro loop forms `(do () (()) ,@forms))

(defmacro dolist ((stepper starter) .forms)
 (let ((var (gensym)))
 `(do ((,var ,starter (cdr ,var))
       (,stepper nil))
      ((null ,var))
   (setq ,stepper (car ,var))
   ,@forms)))

(defun union (l1 l2)
 (do ((l1 l1 (cdr l1))
      (l l2))
     ((null l1) l)
     (unless (memq (car l1) l2) (push (car l1) l))))

(declare (special *node-alist*) (special *cl*))

(defmacro node-record-exists (node) `(assq ,node *node-alist*))

(defmacro find-node-record (node) `(cadr (assq ,node *node-alist*)))

(defun init () (setq *node-alist* nil))

(defmacro defclass (class superclasses ignore)
 (let ((class-record ()))
  (let ((class-record-entry (node-record-exists class)))
   (cond (class-record-entry
	  (setq class-record (node-record class-record-entry)))
	 (t (setq class-record (make-node-record name class))
	    (push `(,class ,class-record) *node-alist*))))
  (when superclasses
   (let ((class1-record ())
	 (class2-record ()))
     (let ((class1-record-entry (node-record-exists (car superclasses))))
      (cond (class1-record-entry
	     (setq class1-record (node-record class1-record-entry)))
	    (t (setq class1-record (make-node-record name (car superclasses)))
	       (push 
	       ` (,(car superclasses) ,class1-record) *node-alist*))))
   (do ((sc superclasses (cdr sc))
        (ds nil))
       ((null sc) (setf (direct-superclasses class-record) (reverse ds)))
    (let ((class2 (cadr sc)))
     (push class1-record ds)
     (when class2
      (let ((class2-record-entry (node-record-exists class2)))
       (cond (class2-record-entry
	      (setq class2-record (node-record class2-record-entry)))
	     (t
	        (setq class2-record (make-node-record name class2))
	        (push 
		` (,class2 ,class2-record) *node-alist*))))
      (record-sibling-relation class1-record class2-record))
     (record-parent-relation class-record class1-record)
     (setq class1-record class2-record))))))
 `(quote ,class))

;;; Records that node2 is a direct superclass of node1
;;;
(defun record-parent-relation (node1-record node2-record)
  (incf (count node2-record))
  (name node1-record))

;;; Records that node2 is a direct sibling of node1
;;;
(defun record-sibling-relation (node1-record node2-record)
 (unless (memq node2-record (direct-siblings node1-record))
	 (incf (count node2-record))
	 (setf (direct-siblings node1-record) 
	       (cons node2-record (direct-siblings node1-record))))
  (name node1-record))

(defun walk (class-name)
 (let ((*cl* ()))
  (walk1 (find-node-record class-name))
  (reverse *cl*)))

(defun walk1 (c)
;(print `((walking ,(name c)) (count ,(count c))))
 (unless (already-visited c)
	 (when (zerop (count c))
	       (visit c)
	       (dolist (super (direct-superclasses c))
		       (decf (count super)))
	       (dolist (super (direct-siblings c))
		       (decf (count super)))
	       (dolist (super (direct-superclasses c))
		       (walk1 super))
	       (dolist (super (direct-siblings c))
		       (walk1 super)))))

(defun visit (c)
       (setf (already-visited c) t)
       (push (name c) *cl*))